module TM ( makeTM
          , simulate
          , trace ) where

import qualified Data.Map as Map (fromList, lookup)
import Data.Map (Map)
import Data.Maybe (isNothing, fromJust)
import Data.List (elemIndex)

type State    = Int
type Symbol   = Char
data Action   = L | H | R deriving (Show, Read, Eq, Enum)
type Tape     = [Symbol]
type Position = Int

type TransitionFunction = Map (State, [Symbol]) (State, [(Symbol, Action)])
data TM = TM TransitionFunction ([(Tape, Position)], State) deriving (Show)

makeTM :: String -> String -> Int -> TM
makeTM tp tr q0 = TM (parseTransitions tr) ((parseTapes tp), q0)

parseTapes t = [(t',0) | t' <- (lines t)]

parseTransitions = (toTransition . readTrans . lines) where
  readTrans = map readTrans' where
    readTrans' :: String -> ((State, [Symbol]),(State, [(Symbol, Action)]))
    readTrans' = read

step :: TM -> Maybe (TM, Bool)
step (TM delta (l,s)) 
    | isNothing transition = Nothing
    | otherwise            = Just ((TM delta (nL, nS)), hasHaltingState trans)
    where transition = getTransition delta s (readSymbol l)
          nS         = (fst . fromJust) transition
          trans      = (snd . fromJust) transition
          nL         = performMultAction l trans

readSymbol :: [(Tape, Position)] -> Tape
readSymbol = foldr (\t next -> (fst t) !! (snd t) : next) []

getTransition :: TransitionFunction -> State -> Tape -> Maybe (State, [(Symbol, Action)])
getTransition delta state symList = Map.lookup (state, symList) delta

performMultAction :: [(Tape, Position)] -> [(Symbol, Action)] -> [(Tape, Position)]
performMultAction []     _      = []
performMultAction (a:as) (b:bs) = performAction a b : performMultAction as bs

performAction :: (Tape, Position) -> (Symbol, Action) -> (Tape, Position)
performAction (t, p) (s, a) = (makeTape t s p a, nP p a)
    where nP 0 L = 0
          nP p _ = (((+) p) . pred . fromEnum) a

makeTape :: Tape -> Symbol -> Position -> Action -> Tape
makeTape tape sym 0   L = '#' : sym : drop 1 tape -- tail is unsafe
makeTape tape sym pos a | pos == (length tape)-1 && a == R = take pos tape ++ sym : ['#']
                        | otherwise = take pos tape ++ sym : drop (pos+1) tape

hasHaltingState :: [(Symbol, Action)] -> Bool
hasHaltingState list = if isNothing $ elemIndex H [snd x | x <- list] then False else True

toTransition :: [((State, [Symbol]),(State, [(Symbol, Action)]))] ->
                Map (State, [Symbol]) (State, [(Symbol, Action)])
toTransition = Map.fromList

simulate :: TM -> IO ()
simulate mt = sim' (Just (mt,False)) where
    sim' Nothing         = putStrLn "-- rejected --"
    sim' (Just (_,True)) = putStrLn "-- accepted --"
    sim' (Just (mt,_))   = (sim' . step) mt

trace :: TM -> IO ()
trace mt = trace' (Just (mt,False)) 0 where
    trace' Nothing         _ = putStrLn "-- rejected --"
    trace' (Just (_,True)) _ = putStrLn "-- accepted --"
    trace' mt@(Just ((TM _ v),_)) s = do
        putStrLn $ "-- step: " ++ show s ++ " -- state: " ++ show (snd v)
        printTapes (fst v) >> trace' ((step . fst . fromJust) mt) (s+1)
        where printTapes [] = return ()
              printTapes (h:t) = printTape h >> printTapes t
               where printTape (t, p) = do
                     putStrLn t
                     putStrLn $ replicate p ' ' ++ "^\n"